home *** CD-ROM | disk | FTP | other *** search
VERSION 5.00 Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX" Object = "{54F463F3-0135-11D2-8D52-00C04FA4EE99}#7.2#0"; "VBALTBAR.OCX" Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX" Begin VB.Form frmMain Caption = "Developers Code Book" ClientHeight = 6855 ClientLeft = 1605 ClientTop = 2145 ClientWidth = 8235 BeginProperty Font Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Icon = "frmMain.frx":0000 LinkTopic = "Form1" ScaleHeight = 6855 ScaleWidth = 8235 Begin prjDevBook.ctlData ctlData1 Height = 2655 Left = 3360 TabIndex = 10 Top = 720 Width = 3735 _ExtentX = 6588 _ExtentY = 4683 End Begin prjDevBook.ctlFavourites ctlFavourites1 Height = 1935 Left = 120 TabIndex = 3 Top = 4200 Width = 6615 _ExtentX = 11668 _ExtentY = 3413 End Begin VB.Timer tmrDragTimer Enabled = 0 'False Interval = 100 Left = 3240 Top = 2280 End Begin ComctlLib.ProgressBar pgb Height = 255 Left = 1920 TabIndex = 4 Top = 5280 Visible = 0 'False Width = 1575 _ExtentX = 2778 _ExtentY = 450 _Version = 327682 Appearance = 1 End Begin MSComDlg.CommonDialog cmdDialog Left = 480 Top = 5640 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin VB.TextBox txtTemp Height = 375 Left = 3480 MultiLine = -1 'True TabIndex = 9 Top = 5640 Visible = 0 'False Width = 2055 End Begin VB.ComboBox cboFind Height = 315 Left = 1440 TabIndex = 8 Text = "Find..." Top = 5640 Width = 1935 End Begin VB.PictureBox picToolbar BorderStyle = 0 'None BeginProperty Font Name = "Tahoma" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 615 Left = 0 ScaleHeight = 615 ScaleWidth = 8295 TabIndex = 5 Top = 0 Width = 8295 Begin vbalTBar.cToolbarHost tbhMenu Height = 255 Left = 3840 TabIndex = 7 Top = 120 Width = 495 _ExtentX = 873 _ExtentY = 450 End Begin vbalTBar.cToolbarHost tbhMain Height = 255 Left = 3000 TabIndex = 6 Top = 0 Width = 615 _ExtentX = 1085 _ExtentY = 450 End Begin vbalTBar.cToolbar tbrMenu Left = 2280 Top = 120 _ExtentX = 1720 _ExtentY = 450 End Begin vbalTBar.cToolbar tbrMain Left = 1440 Top = 120 _ExtentX = 1296 _ExtentY = 450 End Begin vbalTBar.cReBar rbrMain Left = 0 Top = 0 _ExtentX = 2143 _ExtentY = 661 End End Begin VB.PictureBox picSplit BackColor = &H80000003& BorderStyle = 0 'None BeginProperty Font Name = "Tahoma" Size = 9 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 4800 Left = 3000 MousePointer = 9 'Size W E ScaleHeight = 4800 ScaleWidth = 75 TabIndex = 2 Top = 420 Visible = 0 'False Width = 72 End Begin ComctlLib.StatusBar stbBar Align = 2 'Align Bottom Height = 255 Left = 0 TabIndex = 1 Top = 6600 Width = 8235 _ExtentX = 14526 _ExtentY = 450 SimpleText = "" _Version = 327682 BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} NumPanels = 1 BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} Key = "" Object.Tag = "" EndProperty EndProperty End Begin ComctlLib.TreeView tvwItems Height = 3255 Left = 120 TabIndex = 0 Top = 480 Width = 2385 _ExtentX = 4207 _ExtentY = 5741 _Version = 327682 HideSelection = 0 'False Indentation = 353 LabelEdit = 1 LineStyle = 1 Sorted = -1 'True Style = 7 ImageList = "imgIcons" BorderStyle = 1 Appearance = 1 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty OLEDropMode = 1 End Begin ComctlLib.ImageList ilsMenu Left = 4320 Top = 3120 _ExtentX = 1005 _ExtentY = 1005 BackColor = 12632256 ImageWidth = 16 ImageHeight = 16 MaskColor = 12632256 _Version = 327682 BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} NumListImages = 29 BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":014A Key = "" EndProperty BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":049C Key = "" EndProperty BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":07EE Key = "" EndProperty BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":0B40 Key = "" EndProperty BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":0E92 Key = "" EndProperty BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":11E4 Key = "" EndProperty BeginProperty ListImage7 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":1536 Key = "" EndProperty BeginProperty ListImage8 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":1888 Key = "" EndProperty BeginProperty ListImage9 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":1BDA Key = "" EndProperty BeginProperty ListImage10 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":1F2C Key = "" EndProperty BeginProperty ListImage11 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":227E Key = "" EndProperty BeginProperty ListImage12 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":25D0 Key = "" EndProperty BeginProperty ListImage13 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":2922 Key = "" EndProperty BeginProperty ListImage14 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":2C74 Key = "" EndProperty BeginProperty ListImage15 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":2FC6 Key = "" EndProperty BeginProperty ListImage16 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":3318 Key = "" EndProperty BeginProperty ListImage17 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":366A Key = "" EndProperty BeginProperty ListImage18 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":39BC Key = "" EndProperty BeginProperty ListImage19 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":3D0E Key = "" EndProperty BeginProperty ListImage20 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":4060 Key = "" EndProperty BeginProperty ListImage21 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":43B2 Key = "" EndProperty BeginProperty ListImage22 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":4704 Key = "" EndProperty BeginProperty ListImage23 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":4A56 Key = "" EndProperty BeginProperty ListImage24 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":4DA8 Key = "" EndProperty BeginProperty ListImage25 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":50FA Key = "" EndProperty BeginProperty ListImage26 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":544C Key = "" EndProperty BeginProperty ListImage27 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":579E Key = "" EndProperty BeginProperty ListImage28 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":5AF0 Key = "" EndProperty BeginProperty ListImage29 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":5E42 Key = "" EndProperty EndProperty End Begin ComctlLib.ImageList imgPics Left = 3000 Top = 3120 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 ImageWidth = 16 ImageHeight = 16 MaskColor = 12632256 _Version = 327682 BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} NumListImages = 13 BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":6196 Key = "CLIP" EndProperty BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":64E8 Key = "COLOUR" EndProperty BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":683A Key = "COPY" EndProperty BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":6B8C Key = "CUT" EndProperty BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":6EDE Key = "DELETE" EndProperty BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":7230 Key = "FAVOURITES" EndProperty BeginProperty ListImage7 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":7582 Key = "FIND" EndProperty BeginProperty ListImage8 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":78D4 Key = "NEW" EndProperty BeginProperty ListImage9 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":7C26 Key = "NEXT" EndProperty BeginProperty ListImage10 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":7F78 Key = "PASTE" EndProperty BeginProperty ListImage11 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":82CA Key = "PREVIOUS" EndProperty BeginProperty ListImage12 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":861C Key = "PRINT" EndProperty BeginProperty ListImage13 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":896E Key = "SELECTALL" EndProperty EndProperty End Begin VB.Image imgSplitter Height = 4785 Left = 2625 MousePointer = 9 'Size W E Top = 360 Width = 195 End Begin ComctlLib.ImageList imgIcons Left = 3600 Top = 3120 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 ImageWidth = 16 ImageHeight = 16 MaskColor = 12632256 _Version = 327682 BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} NumListImages = 6 BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":8CC0 Key = "CLASS" EndProperty BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":8F82 Key = "OPEN" EndProperty BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":92D4 Key = "CLOSED" EndProperty BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":9626 Key = "CODE" EndProperty BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":990C Key = "MODULE" EndProperty BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7} Picture = "frmMain.frx":9BFE Key = "ROOT" EndProperty EndProperty End Attribute VB_Name = "frmMain" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False '---------------------------------------- '- Name: Sam Huggill '- Email: sam@vbsquare.com '- Web: http://www.vbsquare.com/ '- Company: Lighthouse Internet Solutions '- Date/Time: 14/08/99 11:33:00 '---------------------------------------- '- Notes: Main form that operates most of ' the UI '---------------------------------------- Option Explicit Public VBInstance As VBIDE.VBE Public Connect As Connect Private WithEvents m_cMenu As cPopupMenu ' File menu Attribute m_cMenu.VB_VarHelpID = -1 Private WithEvents m_cTree As cPopupMenu ' Treeview context menu Attribute m_cTree.VB_VarHelpID = -1 Private mbSplitting As Boolean '// Are we splitting? Private m_blnShowCPL As Boolean Private Const lVSplitLimit As Long = 1500 '// Splitter side limits Private m_nodNode As Node '// Node handler Private miClipBoardFormat As Integer '// Custom Clipboard format Private mnDragNode As Node '// Dragged Node Private miScrollDir As Integer '// Scroll direction Private m_blnControl As Boolean '// Show the control panel Private m_blnDBLoaded As Boolean Private Sub cboFind_KeyUp(KeyCode As Integer, Shift As Integer) On Error GoTo vbErrHand ' Detect the return key If KeyCode = vbKeyReturn Then ' Find the text frmFind.optEntire = True frmFind.FindItem cboFind.Text, tvwItems AddQuickFind cboFind.Text tvwItems.SetFocus DoEvents Unload frmFind End If Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "cboFind_KeyUp", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "cboFind_KeyUp" End Sub Private Sub ctlData1_GotFocus() Dim Control As Object On Error Resume Next ' Loop through all the controls and make sure ' that the edit box keeps the focus and therefore ' will accept tabs For Each Control In Controls Control.TabStop = False Next Control End Sub Private Sub Form_Load() On Error GoTo vbErrHand m_blnDBLoaded = False ' Open the DB If modData.OpenDB(modMain.LastDB) Then m_blnDBLoaded = True Me.Caption = Me.Caption & " " & modMain.LastDB ' Load the items into the tree modData.FillTree tvwItems QuickFind cboFind ' Call our startup proc StartUp End If Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "Form_Load", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "Form_Load" End Sub Private Sub StartUp() Dim ctl As Control Dim intCount As Integer On Error GoTo vbErrHand CentreForm Me '// Get out registry settings GetSettings '// Show/Hide our control panel ctlData1.Initalize ctlFavourites1.Initalize InitColorize InitToolbar ShowProgressInStatusBar True ShowCPL m_blnControl miClipBoardFormat = RegisterClipboardFormat("DCB") '// Make the tree a reasonable width SizeControls (tvwItems.Width * 3) / 2 Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "Startup", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "Startup" End Sub Private Sub Form_Resize() '// Resize our controls SizeControls tvwItems.Width End Sub Private Sub Form_Unload(Cancel As Integer) ' On Error GoTo vbErrHand UnloadMe '// Free up some memory here... If Not (m_cMenu Is Nothing) Then m_cMenu.Clear m_cMenu.DestroySubClass End If If Not (m_cTree Is Nothing) Then m_cTree.Clear m_cTree.DestroySubClass End If If Not (tbrMain Is Nothing) Then tbrMain.DestroyToolBar End If If Not (tbrMenu Is Nothing) Then tbrMenu.DestroyToolBar End If If Not (rbrMain Is Nothing) Then rbrMain.RemoveAllRebarBands rbrMain.DestroyRebar End If Set m_cMenu = Nothing Set m_cTree = Nothing '// Free up memory in the DB module Call modData.SetNothing Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "Form_Unload", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "Form_Unload" End Sub Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) '// Initalize the splitting action '// Thanks to Chris Eastwood for this (and many other things) With imgSplitter picSplit.Move .left, .tOp, .Width \ 2, .Height - 20 End With picSplit.Visible = True mbSplitting = True End Sub Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim sglPos As Single 'Check if we are splitting: If so show the splitter 'bar and move the controls If mbSplitting Then sglPos = X + imgSplitter.left If sglPos < lVSplitLimit Then picSplit.left = lVSplitLimit ElseIf sglPos > Me.Width - lVSplitLimit Then picSplit.left = Me.Width - lVSplitLimit Else picSplit.left = sglPos End If End If End Sub Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) '// Resize the form and hide the splitter bar SizeControls picSplit.left picSplit.Visible = False mbSplitting = False End Sub Private Sub m_cMenu_Click(ItemNumber As Long) On Error GoTo vbErrHand '// Handles the menu items Select Case m_cMenu.ItemKey(ItemNumber) Case "NEW" modFiles.NewDB ShowFileDialog(eSave, "", "Save New DB As..", "Access Database (*.mdb)|*.mdb| All Files (*.*)|*.*|") Case "CPL" ShowCPL Not (ctlFavourites1.Visible) Case "OPEN" modFiles.OpenDB ShowFileDialog(eOpen, "", "Open Database", "Database|*.mdb") Me.Caption = "Developers Code Book " & modData.DBName Case "FAVOURITES" If tvwItems.SelectedItem Is Nothing Then MsgBox "No item selected.", vbOKOnly + vbInformation Exit Sub End If If tvwItems.SelectedItem.Key <> "ROOT" Then ctlFavourites1.AddItem tvwItems End If Case "README" ShellExecute 0&, vbNullString, App.Path & "\readme.txt", vbNullString, vbNullString, vbNormalFocus Case "NET" ShellExecute 0&, vbNullString, "http://www.programmerz.com/vb/dev/", vbNullString, vbNullString, vbNormalFocus Case "REMOVE" If tvwItems.SelectedItem Is Nothing Then MsgBox "No item selected.", vbOKOnly + vbInformation Exit Sub End If If tvwItems.SelectedItem.Key <> "ROOT" Then ctlFavourites1.DeleteItem tvwItems End If Case "RENAME" tvwItems.StartLabelEdit Case "UNDO" ctlData1.Undo Case "CUT" ctlData1.Cut Case "COPY" ctlData1.Copy Case "PASTE" ctlData1.Paste Case "SELECTALL" ctlData1.SelectAll Case "PROPERTIES" Dim mNode As Node Set mNode = tvwItems.SelectedItem If mNode Is Nothing Then MsgBox "No Item selected." Exit Sub End If If mNode.Key = "ROOT" Then MsgBox "Properties for the root node cannot be viewed." Exit Sub End If frmAdd.Caption = "Properties for: " & tvwItems.SelectedItem.Text frmAdd.cmdAdd.Visible = False frmAdd.cmdApply.Visible = True frmAdd.txtDescription = tvwItems.SelectedItem.Text frmAdd.txtNotes = ctlData1.PlainNotes frmAdd.cmdApply.Default = True frmAdd.optLevel(0).Enabled = False frmAdd.optLevel(1).Enabled = False Select Case g_strVersion Case "VB4 16" frmAdd.cboVersion.ListIndex = 0 Case "VB4 32" frmAdd.cboVersion.ListIndex = 1 Case "VB5" frmAdd.cboVersion.ListIndex = 2 Case "VB6" frmAdd.cboVersion.ListIndex = 3 Case Else End Select Select Case g_strLevel Case "Beginner" frmAdd.cboLevel.ListIndex = 0 Case "Intermediate" frmAdd.cboLevel.ListIndex = 1 Case "Advanced" frmAdd.cboLevel.ListIndex = 2 Case Else End Select frmAdd.Show vbModal Case "OPTIONS" frmOptions.Show vbModal Case "ABOUT" frmAbout.Show vbModal Case "EXIT" 'Exit Unload Me 'End Case Else End Select Set mNode = Nothing Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "m_cMenu_Click", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "m_cMenu_Click" End Sub Private Sub m_cTree_Click(ItemNumber As Long) Dim obj As VBIDE.VBComponent On Error Resume Next ' Handles the treeview's menu items Select Case m_cTree.ItemKey(ItemNumber) Case "ADD" frmAdd.Show vbModal Case "FOLDER" modData.AddFolder tvwItems, ctlData1 Case "IMPORT" modData.Key = tvwItems.SelectedItem.Key modData.ImportCodeItems tvwItems Case "DCB" modFiles.ExportFile tvwItems.SelectedItem.Key, tvwItems, ctlData1 modData.SelectItem tvwItems.SelectedItem.Key, ctlData1 Case "NEWMOD" ' Import the current code If Not (Me.VBInstance Is Nothing) Then Set obj = VBInstance.ActiveVBProject.VBComponents.Add(vbext_ct_StdModule) obj.CodeModule.AddFromString ctlData1.PlainCode obj.Name = tvwItems.SelectedItem.Text obj.Activate End If Case "NEWCLS" If Not (Me.VBInstance Is Nothing) Then Set obj = VBInstance.ActiveVBProject.VBComponents.Add(vbext_ct_ClassModule) obj.CodeModule.AddFromFile ctlData1.PlainCode obj.Name = tvwItems.SelectedItem.Text obj.Activate End If Case "DEL" If tvwItems.SelectedItem Is Nothing Then MsgBox "No item selected.", vbOKOnly + vbInformation Exit Sub End If modData.Key = tvwItems.SelectedItem.Key modData.DeleteNode tvwItems Case "HTML" SourceToHTML ctlData1.Code Case "ADDFAVS" If tvwItems.SelectedItem Is Nothing Then MsgBox "No item selected.", vbOKOnly + vbInformation Exit Sub End If If tvwItems.SelectedItem.Key <> "ROOT" Then ctlFavourites1.AddItem tvwItems End If Case "REMFAVS" If tvwItems.SelectedItem Is Nothing Then MsgBox "No item selected.", vbOKOnly + vbInformation Exit Sub End If If tvwItems.SelectedItem.Key <> "ROOT" Then ctlFavourites1.DeleteItem tvwItems End If Case "PROPS" Dim mNode As Node Set mNode = tvwItems.SelectedItem If mNode Is Nothing Then MsgBox "No Item selected." Exit Sub End If If mNode.Key = "ROOT" Then MsgBox "Properties for the root node cannot be viewed." Exit Sub End If frmAdd.Caption = "Properties for: " & tvwItems.SelectedItem.Text frmAdd.cmdAdd.Visible = False frmAdd.cmdApply.Visible = True frmAdd.txtDescription = tvwItems.SelectedItem.Text frmAdd.txtNotes = ctlData1.PlainNotes frmAdd.cmdApply.Default = True frmAdd.optLevel(0).Enabled = False frmAdd.optLevel(1).Enabled = False Select Case g_strVersion Case "4 16" frmAdd.cboVersion.ListIndex = 0 Case "4 32" frmAdd.cboVersion.ListIndex = 1 Case "5" frmAdd.cboVersion.ListIndex = 2 Case Else End Select Select Case g_strLevel Case "Beginner" frmAdd.cboLevel.ListIndex = 0 Case "Intermediate" frmAdd.cboLevel.ListIndex = 1 Case "Advanced" frmAdd.cboLevel.ListIndex = 2 Case Else End Select frmAdd.Show vbModal Case Else End Select Set mNode = Nothing End Sub Private Sub picToolbar_Resize() '// Make sure we can see our toolbar rbrMain.RebarSize picToolbar.Height = rbrMain.RebarHeight * Screen.TwipsPerPixelY End Sub Private Sub rbrMain_HeightChanged(lNewHeight As Long) picToolbar.Height = lNewHeight * Screen.TwipsPerPixelY Form_Resize End Sub Private Sub tbrMain_ButtonClick(ByVal lButton As Long) On Error GoTo vbErrHand Dim lRet As Long '// Handle button clicks Select Case tbrMain.ButtonKey(lButton) Case "UNDO" If ctlData1.CanUndo Then ctlData1.Undo End If Case "UP" MoveUp tvwItems Case "DOWN" MoveDown tvwItems Case "NEW" frmAdd.Show vbModal Case "SAVE" If tvwItems.SelectedItem Is Nothing Then Exit Sub modData.Key = tvwItems.SelectedItem.Key modData.Code = ctlData1.Code modData.Example = ctlData1.Example modData.Notes = ctlData1.Notes modData.Description = ctlData1.Caption modData.UpdateDB tvwItems Case "DELETE" If tvwItems.SelectedItem Is Nothing Then MsgBox "No item selected.", vbOKOnly + vbInformation Exit Sub End If modData.DeleteNode tvwItems Case "COLOUR" ctlData1.Colour Case "FIND" frmFind.Show vbModal Case "ADDFAVS" If tvwItems.SelectedItem Is Nothing Then MsgBox "No item selected.", vbOKOnly + vbInformation Exit Sub End If ctlFavourites1.AddItem tvwItems Case "CUT" ctlData1.Cut Case "COPY" ctlData1.Copy Case "PASTE" ctlData1.Paste Case "SELECTALL" ctlData1.SelectAll Case "PRINT" lRet = MsgBox("Are you sure you want to print:" & vbCrLf & ctlData1.Caption & "?", vbYesNo + vbInformation) If lRet = vbNo Then Exit Sub 'Print It ctlData1.PrintCode Case Else End Select Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "tbrMain_ButtonClick", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "tbrMain_ButtonClick" End Sub Private Sub tmrDragTimer_Timer() Dim nHitNode As Node Static lCount As Long ' ' This timer has two functions : ' ' 1 - It will scroll the TreeView when the user is dragging ' ' 2 - It will auto-expand a node when the user drags over it for more than ' half a second. ' ' Both pieces of code stolen from the MDSN. ' If mnDragNode Is Nothing Then tmrDragTimer.Enabled = False Exit Sub End If lCount = lCount + 1 If lCount > 10 Then Set nHitNode = tvwItems.DropHighlight If nHitNode Is Nothing Then Exit Sub If nHitNode.Expanded = False Then nHitNode.Expanded = True End If lCount = 0 End If If miScrollDir <> 0 Then If miScrollDir = -1 Then SendMessageLong tvwItems.hwnd, WM_VSCROLL, 0, 0 Else SendMessageLong tvwItems.hwnd, WM_VSCROLL, 1, 0 End If End If End Sub Private Sub tvwItems_AfterLabelEdit(Cancel As Integer, NewString As String) modData.Key = tvwItems.SelectedItem.Key modData.Description = NewString modData.UpdateDB tvwItems SelectItem tvwItems.SelectedItem.Key, ctlData1 End Sub Private Sub tvwItems_BeforeLabelEdit(Cancel As Integer) If tvwItems.SelectedItem.Key = "ROOT" Then Cancel = True End Sub Private Sub tvwItems_Collapse(ByVal Node As ComctlLib.Node) On Error GoTo vbErrHand If Node.Key = "ROOT" Then Exit Sub Node.Image = "CLOSED" modData.SelectItem Node.Key, ctlData1 Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "Collapse", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "Collapse" End Sub Private Sub tvwItems_Expand(ByVal Node As ComctlLib.Node) On Error GoTo vbErrHand If Node.Key = "ROOT" Then Exit Sub Node.Image = "OPEN" modData.SelectItem Node.Key, ctlData1 Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "Expand", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "Expand" End Sub Private Sub tvwItems_KeyUp(KeyCode As Integer, Shift As Integer) '// Detect key presses of Insert and Delete Dim intPos As Integer If KeyCode = vbKeyDelete Then modData.Key = tvwItems.SelectedItem.Key modData.DeleteNode tvwItems End If If KeyCode = vbKeyInsert Then frmAdd.Show vbModal End If End Sub Private Sub tvwItems_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Set mnDragNode = tvwItems.HitTest(X, Y) End Sub Private Sub tvwItems_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If mnDragNode Is Nothing Then Exit Sub If Button = vbLeftButton Then If mnDragNode.Key <> "ROOT" Then ' ' Start Dragging ! ' Set tvwItems.SelectedItem = mnDragNode tmrDragTimer.Interval = 100 tmrDragTimer.Enabled = True tvwItems.OLEDrag End If Else Set mnDragNode = Nothing End If End Sub Private Sub tvwItems_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) On Error GoTo vbErrHand Dim blnIsRoot As Boolean '// Shows our context menu If tvwItems.SelectedItem Is Nothing Then Exit Sub If Button = vbRightButton Then blnIsRoot = (StrComp(tvwItems.SelectedItem.Index, "1", vbTextCompare) = 0) m_cTree.Restore "TreeMenu" m_cTree.Enabled(m_cTree.IndexForKey("ADDFAVS")) = Not (blnIsRoot) m_cTree.Enabled(m_cTree.IndexForKey("DEL")) = Not (blnIsRoot) m_cTree.Enabled(m_cTree.IndexForKey("REMFAVS")) = Not (blnIsRoot) m_cTree.Enabled(m_cTree.IndexForKey("PROPS")) = Not (blnIsRoot) If Not blnIsRoot And GetVersion = 3 Then m_cTree.Enabled(m_cTree.IndexForKey("ADD")) = InStr(tvwItems.SelectedItem.Key, "F") m_cTree.Enabled(m_cTree.IndexForKey("FOLDER")) = InStr(tvwItems.SelectedItem.Key, "F") Else: If GetVersion = 2 Then m_cTree.Enabled(m_cTree.IndexForKey("FOLDER")) = False End If If InStr(tvwItems.SelectedItem.Key, "F") Then m_cTree.Caption(m_cTree.IndexForKey("DEL")) = "&Delete Folder" m_cTree.Enabled(m_cTree.IndexForKey("HTML")) = False Else m_cTree.Caption(m_cTree.IndexForKey("DEL")) = "&Delete Item" m_cTree.Enabled(m_cTree.IndexForKey("HTML")) = True End If If Not (Me.VBInstance Is Nothing) Then m_cTree.Enabled(m_cTree.IndexForKey("NEWMOD")) = True m_cTree.Enabled(m_cTree.IndexForKey("NEWCLS")) = True Else m_cTree.Enabled(m_cTree.IndexForKey("NEWMOD")) = False m_cTree.Enabled(m_cTree.IndexForKey("NEWCLS")) = False End If Call m_cTree.ShowPopupMenu(X + tvwItems.left, Y + tvwItems.tOp) End If Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "tvwItems_MouseUp", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "tvwItems_MouseUp" End Sub Private Sub tvwItems_NodeClick(ByVal Node As ComctlLib.Node) '// Selects our item On Error GoTo vbErrHand modData.Code = ctlData1.Code modData.Key = tvwItems.SelectedItem.Key modData.SelectItem Node.Key, ctlData1 Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "NodeClick", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "NodeClick" End Sub Private Sub SizeControls(ByVal X As Long) On Error Resume Next picToolbar.Width = Me.ScaleWidth * 2 picToolbar.Height = tbrMain.ToolbarHeight * 2 tbhMain.Width = Me.ScaleWidth tbhMenu.Width = Me.ScaleWidth '-- ' Size all controls based on the splitter bar by Chris Eastwood '-- Dim lHeightOffSet As Long 'set the width If X < 1500 Then X = 1500 If X > (Me.Width - 1500) Then X = Me.Width - 1500 If m_blnControl Then ctlFavourites1.Height = Me.ScaleHeight * (2 / 8) lHeightOffSet = ctlFavourites1.Height Else lHeightOffSet = 0 End If With imgSplitter .left = X .Width = 150 .ZOrder End With With tvwItems .Move ScaleLeft, picToolbar.Height, X, Me.ScaleHeight - (stbBar.Height + picToolbar.Height + lHeightOffSet) End With With ctlData1 .Move X + 25, tvwItems.tOp, Me.ScaleWidth - (tvwItems.Width + 50), tvwItems.Height End With With ctlFavourites1 .Move ScaleLeft, tvwItems.tOp + tvwItems.Height, ScaleWidth, lHeightOffSet End With imgSplitter.tOp = tvwItems.tOp imgSplitter.Height = tvwItems.Height End Sub Private Sub BuildMenus() On Error GoTo vbErrHand '// Builds our menus Dim iP(0 To 26) As Long '// Init the menu Set m_cMenu = New cPopupMenu With m_cMenu .ImageList = ilsMenu .hwndOwner = Me.hwnd .GradientHighlight = True .Clear '// Add the items iP(0) = .AddItem("&File", , , , , , , "mnuFileTop") iP(1) = .AddItem("&New Database" & vbTab & "Ctrl+N", , , iP(0), 0, , , "NEW") iP(2) = .AddItem("&Open Database", , , iP(0), 1, , , "OPEN") iP(3) = .AddItem("-", , , iP(0), , , , "SEP1") iP(4) = .AddItem("&Add to Favourites", , , iP(0), 2, , , "FAVOURITES") iP(5) = .AddItem("&Remove from Favourites", , , iP(0), 3, , , "REMOVE") iP(6) = .AddItem("-", , , iP(0), , , , "SEP2") iP(7) = .AddItem("Rename Item", , , iP(0), 4, , , "RENAME") iP(8) = .AddItem("-", , , iP(0), , , , "SEP3") iP(9) = .AddItem("E&xit", , , iP(0), , , , "EXIT") iP(10) = .AddItem("&Edit", , , , , , , "mnuEditTop") iP(11) = .AddItem("&Undo" & vbTab & "Ctrl+Z", , , iP(10), 5, , , "UNDO") iP(12) = .AddItem("-", , , iP(10), , , , "SEP4") iP(13) = .AddItem("Cu&t" & vbTab & "Ctrl+X", , , iP(10), 6, , , "CUT") iP(14) = .AddItem("&Copy" & vbTab & "Ctrl+C", , , iP(10), 7, , , "COPY") iP(15) = .AddItem("&Paste" & vbTab & "Ctrl+V", , , iP(10), 8, , , "PASTE") iP(16) = .AddItem("Select &All" & vbTab & "Ctrl+A", , , iP(10), , , , "SELECTALL") iP(17) = .AddItem("&View", , , , , , , "mnuViewTop") iP(18) = .AddItem("&Control Panel", , , iP(17), , True, , "CPL") iP(19) = .AddItem("&Properties", , , iP(17), 9, , , "PROPERTIES") iP(20) = .AddItem("-", , , iP(17), , , , "SEP5") iP(21) = .AddItem("&Options", , , iP(17), 10, , , "OPTIONS") iP(22) = .AddItem("&Help", , , , , , , "mnuHelpTop") iP(23) = .AddItem("On the &net", , , iP(22), 11, , , "NET") iP(24) = .AddItem("&Readme", , , iP(22), 12, , , "README") iP(25) = .AddItem("-", , , iP(22), , , , "SEP6") iP(26) = .AddItem("About...", , , iP(22), , , , "ABOUT") .Store "BaseMenu" End With Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "BuildMenus", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "BuildMenus" End Sub Private Sub AddQuickFind(strText As String) On Error GoTo vbErrHand Dim intFile As Integer Dim strFileName As String '// Adds a new entry to the QuickFind feature strFileName = App.Path & "\quickfind.log" intFile = FreeFile Open strFileName For Append As #intFile Print #intFile, strText Close #intFile Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "AddQuickFind", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "AddQuickFind" End Sub 'Private Function ColourComments(ByVal strText As String) As String ' Dim intPos As Integer ' Dim strChar As String ' Dim blnOpenQuote As Boolean ' '// Colours our comments green ' '// Original code by Rod Stephens ' For intPos = 1 To Len(strText) ' strChar = mID$(strText, intPos, 1) ' If strChar = """" Then ' blnOpenQuote = Not blnOpenQuote ' ElseIf (strChar = "'") And (Not blnOpenQuote) Then ' Exit For ' End If ' Next intPos ' If intPos <= Len(strText) Then ' ColourComments = left$(strText, intPos - 1) & _ ' "<font colour=#007F00>" & "'" & mID$(strText, intPos + 1) & "</font>" ' Else ' ColourComments = strText ' End If 'End Function Private Sub QuickFind(cbo As Object) Dim strFile As String Dim intFile As Integer Dim strNextChar As String * 1 Dim strLine As String Dim intCounter As Integer Dim lngRet As Long On Error GoTo vbErrHand '// Returns the QuickFind entries strFile = App.Path & "\quickfind.log" intFile = FreeFile If Dir$(strFile) = "" Then Exit Sub Open strFile For Input As #intFile txtTemp.Text = Input(LOF(intFile), intFile) Close #intFile For intCounter = 1 To Len(txtTemp) strNextChar = mID$(txtTemp, intCounter, 1) If strNextChar = Chr(13) Then cbo.AddItem strLine strLine = "" ElseIf strNextChar = Chr(10) Then Else strLine = strLine & strNextChar End If Next Exit Sub vbErrHand: If Err.Number = 54 Then Close #intFile End If WriteError Err.Number, Err.Description, "QuickFind", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "QuickFind" End Sub Private Sub MoveDown(tvw As TreeView) On Error GoTo vbErrHand '// Moves down and level If tvw.SelectedItem Is Nothing Then Exit Sub Set m_nodNode = tvw.SelectedItem.Next If Not (m_nodNode Is Nothing) Then Set tvw.SelectedItem = m_nodNode modData.SelectItem m_nodNode.Key, ctlData1 Else Set m_nodNode = tvw.SelectedItem.Child If Not (m_nodNode Is Nothing) Then Set tvw.SelectedItem = m_nodNode modData.SelectItem m_nodNode.Key, ctlData1 End If End If Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "MoveDown", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "MoveDown" End Sub Private Sub MoveUp(tvw As TreeView) On Error GoTo vbErrHand '// Moves up a level If tvw.SelectedItem Is Nothing Then Exit Sub Set m_nodNode = tvw.SelectedItem.Previous If Not (m_nodNode Is Nothing) Then If m_nodNode.Key = "ROOT" Then Exit Sub Set tvw.SelectedItem = m_nodNode modData.SelectItem m_nodNode.Key, ctlData1 Else Set m_nodNode = tvw.SelectedItem.Parent If Not (m_nodNode Is Nothing) Then Set tvw.SelectedItem = m_nodNode modData.SelectItem m_nodNode.Key, ctlData1 End If End If Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "MoveUp", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "MoveUp" End Sub Public Function RecursiveCountNodes(nNode As Node, Optional bResetToZero As Boolean = False) As Long Dim nNodeChild As Node Dim iIndex As Integer Static lCount As Long If bResetToZero Then lCount = 0 End If '// Thanks to Chris Eastwood for this ' ' Get Details for item (as long as it's not the Root Item) ' Set nNodeChild = nNode.Child ' ' Now walk through the current parent node's children ' Do While Not (nNodeChild Is Nothing) lCount = lCount + 1 ' ' If the current child node has it's own children... ' RecursiveCountNodes nNodeChild, False ' ' Get the current child node's next sibling ' Set nNodeChild = nNodeChild.Next Loop RecursiveCountNodes = lCount End Function 'Private Function ReplaceString(ByVal sText As String, ByVal strFrom As String, ByVal strTo As String) As String ' Dim intPos As Integer ' Dim strNew As String ' '// Original code by Rod Stephens ' strNew = "" ' Do ' intPos = InStr(sText, strFrom) ' If intPos = 0 Then Exit Do ' strNew = left$(sText, intPos - 1) & strTo ' sText = mID$(sText, intPos + Len(strFrom)) ' Loop ' strNew = strNew & sText ' ReplaceString = strNew 'End Function Sub ShowCPL(blnShow As Boolean) On Error GoTo vbErrHand '// Shows/Hides our control panel m_blnControl = blnShow ctlFavourites1.Visible = m_blnControl Form_Resize m_cMenu.Checked(m_cMenu.IndexForKey("CPL")) = m_blnControl Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "ShowCPL", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "ShowCPL" End Sub Public Function ShowFileDialog(ByVal sType As eFileDialog, ByRef sFIleName As String, ByVal sTitle As String, Optional sFilter As String) As String On Error GoTo vbErrHand '// Shows the common dialog '// Idea from Chris Eastwood If Len(sFilter) = 0 Then sFilter = "All Files |*.*" End If If Len(cmdDialog.InitDir) = 0 Then cmdDialog.InitDir = App.Path End If cmdDialog.CancelError = True cmdDialog.DialogTitle = sTitle If Len(sFIleName) > 0 Then cmdDialog.FileName = sFIleName Else cmdDialog.FileName = "" End If If Len(sFilter) > 0 Then cmdDialog.Filter = sFilter Else cmdDialog.Filter = "" End If cmdDialog.flags = cdlOFNExplorer + cdlOFNHideReadOnly If sType = eOpen Then cmdDialog.ShowOpen Else cmdDialog.flags = cmdDialog.flags + cdlOFNOverwritePrompt cmdDialog.ShowSave End If sFIleName = cmdDialog.FileName If Len(sFIleName) > 0 Then ShowFileDialog = sFIleName End If Exit Function vbErrHand: If Err.Number = 32755 Then ShowFileDialog = "" Exit Function Else WriteError Err.Number, Err.Description, "ShowFileDialog", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "ShowFileDialog" End If End Function Private Sub ShowProgressInStatusBar(ByVal bShowProgressBar As Boolean) '-- 'Loads a progress bar into a status bar pannel 'Authored by Chris Eastwood '-- Dim tRC As RECT If bShowProgressBar Then ' ' Get the size of the Panel (2) Rectangle from the status bar ' remember that Indexes in the API are always 0 based (well, ' nearly always) - therefore Panel(2) = Panel(1) to the api ' ' SendMessageAny stbBar.hwnd, SB_GETRECT, 1, tRC ' ' and convert it to twips.... ' With tRC .tOp = (.tOp * Screen.TwipsPerPixelY) .left = (.left * Screen.TwipsPerPixelX) .Bottom = (.Bottom * Screen.TwipsPerPixelY) - .tOp .Right = (.Right * Screen.TwipsPerPixelX) - .left End With ' ' Now Reparent the ProgressBar to the statusbar ' With pgb SetParent .hwnd, stbBar.hwnd .Move tRC.left, tRC.tOp, tRC.Right, tRC.Bottom .Visible = True .Value = 0 End With Else ' ' Reparent the progress bar back to the form and hide it ' SetParent pgb.hwnd, Me.hwnd pgb.Visible = False End If End Sub Public Function SourceToHTML(ByVal source_text As String) As String On Error GoTo vbErrHand Dim strBuffer As String Dim strHeader As String Dim strFooter As String Dim cHourGlass As CWaitCursor Dim strFile As String Dim intFile As Integer Dim intCount As Integer strHeader = GetSetting(ThisApp, "HTML", "Header", "") strFooter = GetSetting(ThisApp, "HTML", "Footer", "") intFile = FreeFile strFile = ShowFileDialog(eSave, "", "Output File...", "HTML Files (*.htm)|*.htm| All Files (*.*)|*.*|") If strFile = "" Then Exit Function Set cHourGlass = New CWaitCursor cHourGlass.SetCursor strBuffer = RTF2HTML(source_text, "+H", strHeader, strFooter) For intCount = 1 To Len(strBuffer) If intCount = Len(strBuffer) Then pgb.Value = pgb.Value + (100 - pgb.Value) End If If pgb.Value = 100 Then Exit For If (0 + intCount - 1) Mod Int(100 / 200 + 1) = 0 Then pgb.Value = (0 + intCount - 1) stbBar.Panels(1).Text = "Converting..." DoEvents End If Next pgb.Value = 0 stbBar.Panels(1).Text = "" Open strFile For Output As #intFile Write #intFile, strBuffer Close #intFile MsgBox "Code outputted to HTML file at " & strFile Exit Function vbErrHand: WriteError Err.Number, Err.Description, "SourceToHTML", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "SourceToHTML" End Function Private Sub TreeRedraw(ByVal lHwnd As Long, ByVal bRedraw As Boolean) '-- ' Utility Routine for TreeRedraw on/of by Chris Eastwood '-- SendMessageLong lHwnd, WM_SETREDRAW, bRedraw, 0 End Sub Sub BuildTreeMenu() On Error GoTo vbErrHand '// Builds our treeview's menu Dim lngExport As Long '// Init the menu Set m_cTree = New cPopupMenu With m_cTree .ImageList = ilsMenu .hwndOwner = Me.hwnd .GradientHighlight = True .Clear '// Add items .AddItem "New &Item", , , , 0, , , "ADD" .AddItem "New &Folder", , , , 13, , , "FOLDER" .AddItem "Delete Item", , , , 14, , , "DEL" .AddItem "-" .AddItem "Import Item", , , , 15, , , "IMPORT" lngExport = .AddItem("Export Item", , , , 16, , , "EXPORT") .AddItem "DCB File", , , lngExport, , , , "DCB" .AddItem "HTML File", , , lngExport, 11, , , "HTML" .AddItem "New Module in VB", , , lngExport, 27, , , "NEWMOD" .AddItem "New Class in VB", , , lngExport, 28, , , "NEWCLS" .AddItem "-" .AddItem "Add Favourite", , , , 2, , , "ADDFAVS" .AddItem "Remove Favourites", , , , 3, , , "REMFAVS" .AddItem "-" .AddItem "&Properties", , , , 9, , , "PROPS" .Store "TreeMenu" End With Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "BuildTreeMenu", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "BuildTreeMenu" End Sub Sub InitToolbar() On Error GoTo vbErrHand Dim intCount As Integer '// Sets up our toolbar/rebar/cool menu DoEvents BuildMenus tbrMenu.CreateFromMenu m_cMenu With tbhMenu .BorderStyle = etbhBorderStyleNone .MDIToolbar = False .Capture tbrMenu End With With tbrMain .ImageSource = CTBExternalImageList .SetImageList ilsMenu .CreateToolbar 16, , , True .AddButton "UP", 17, , , , , "UP" .AddButton "DOWN", 18, , , , , "DOWN" .AddButton "", , , , , CTBSeparator, "SEP1" .AddButton "New Item", 0, , , , , "NEW" .AddButton "Save Current Code", 19, , , , , "SAVE" .AddButton "Syntax Highlight", 20, , , , , "COLOUR" .AddButton "Delete Item", 14, , , , , "DELETE" .AddButton "Find", 21, , , , , "FIND" .AddButton "Add to Favourites", 2, , , , , "ADDFAVS" .AddButton , , , , , CTBSeparator .AddButton "Cut", 6, , , , , "CUT" .AddButton "Copy", 7, , , , , "COPY" .AddButton "Paste", 8, , , , , "PASTE" .AddButton "Select All", 22, , , , , "SELECTALL" .AddButton "Print", 23, , , , , "PRINT" End With With tbhMain .BorderStyle = etbhBorderStyleNone .Width = Me.ScaleWidth .Height = tbrMain.ToolbarHeight * Screen.TwipsPerPixelY .Capture cboFind .Capture tbrMain End With With rbrMain .Position = erbPositionTop .CreateRebar picToolbar.hwnd .AddBandByHwnd tbhMenu.hwnd, , , , "MENU" .AddBandByHwnd tbhMain.hwnd, , , , "MAINBAR" .BandChildMinWidth(0) = tbrMenu.ToolbarWidth .BandChildMinWidth(1) = tbrMain.ToolbarWidth End With BuildTreeMenu Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "InitToolbar", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "InitToolbar" End Sub Sub GetSettings() Dim sWHeight As String Dim sWWidth As String Dim sWLeft As String Dim sWTop As String Dim sSizes As String Dim sTab As String On Error GoTo vbErrHand '// Retrieve the settings and apply appropiatly sSizes = GetSetting(ThisApp, "General", "Sizes", "0") If sSizes = "1" Then 'Show sizes sWHeight = GetSetting(ThisApp, "General", "WindowHeight", "") sWWidth = GetSetting(ThisApp, "General", "WindowWidth", "") sWLeft = GetSetting(ThisApp, "General", "WindowLeft", "") sWTop = GetSetting(ThisApp, "General", "WindowTop", "") Me.Height = sWHeight Me.Width = sWWidth Me.left = sWLeft Me.tOp = sWTop End If m_blnControl = GetSetting(ThisApp, "General", "ShowControl", True) Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "GetSettings", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "GetSettings" End Sub Private Sub SaveSettings() '// Save the height, width, top and left settings Dim sSizes As String On Error GoTo vbErrHand sSizes = GetSetting(ThisApp, "General", "Sizes", "0") If sSizes = "1" Then If Me.WindowState <> vbMinimized Then SaveSetting ThisApp, "General", "WindowHeight", Me.Height SaveSetting ThisApp, "General", "WindowWidth", Me.Width SaveSetting ThisApp, "General", "WindowLeft", Me.left SaveSetting ThisApp, "General", "WindowTop", Me.tOp End If End If If m_blnControl = True Then SaveSetting ThisApp, "General", "ShowControl", "1" Else SaveSetting ThisApp, "General", "ShowControl", "0" End If SaveSetting ThisApp, "General", "DBPath", modData.DBName Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "SaveSettings", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "SaveSettings" End Sub Public Sub UnloadMe() ' On Error GoTo vbErrHand If m_blnDBLoaded = False Then Exit Sub SaveSettings tvwItems.SetFocus DoEvents modData.SelectItem "ROOT", ctlData1 ctlData1.Terminate ctlFavourites1.Terminate DoEvents '// Backup/Compact/Restore modData.DoActions Exit Sub vbErrHand: WriteError Err.Number, Err.Description, "UnloadMe", Now, App.Path & "\err.log" MsgBox Err.Description, vbCritical + vbOKOnly, "UnloadMe" Resume Next End Sub Private Sub tvwItems_OLECompleteDrag(Effect As Long) Screen.MousePointer = vbDefault tmrDragTimer.Enabled = False End Sub Private Sub tvwItems_OLEDragDrop(Data As ComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) ' ' Handle the dragging and-a dropping of treeview nodes here ' Dim sTmpStr As String Dim oTargetNode As Node Dim sParentKey As String Dim sKey As String Dim oOldParentNode As Node On Error Resume Next ' ' Check whether the clipboard data is in our special defined format ' sTmpStr = Data.GetFormat(miClipBoardFormat) If Err Or sTmpStr = "False" Then ' it's not, so don't allow dropping Set mnDragNode = Nothing Set tvwItems.DropHighlight = Nothing Err.Clear Effect = vbDropEffectNone Exit Sub End If On Error GoTo vbErrorHandler If mnDragNode Is Nothing Then Set mnDragNode = Nothing Set tvwItems.DropHighlight = Nothing Effect = vbDropEffectNone Exit Sub End If Set oTargetNode = tvwItems.DropHighlight ' If oTargetNode Is Nothing Then Set mnDragNode = Nothing Set tvwItems.DropHighlight = Nothing Effect = vbDropEffectNone Exit Sub End If If InStr(oTargetNode.Key, "C") Then MsgBox "You cannot add an item to an existing item, only a folder object." Set mnDragNode = Nothing Set tvwItems.DropHighlight = Nothing Effect = vbDropEffectNone Exit Sub End If Set oOldParentNode = mnDragNode.Parent Set mnDragNode.Parent = oTargetNode ' ' Here's where we handle the drop - don't forget that we have to reparent ' our data objects to point to the new data object (or 0 if root) ' sParentKey = oTargetNode.Key If sParentKey = "ROOT" Then sParentKey = "0" Else sParentKey = Right$(sParentKey, Len(sParentKey) - 1) End If sKey = mnDragNode.Key sKey = Right$(sKey, Len(sKey) - 1) ' 'Update the database ' modData.ParentKey = sParentKey modData.Key = sKey modData.UpdateKey Set tvwItems.DropHighlight = Nothing Set mnDragNode = Nothing tmrDragTimer.Enabled = False If oTargetNode.Key <> "ROOT" Then oTargetNode.ExpandedImage = "OPEN" End If If oOldParentNode.Children <= 1 And oOldParentNode.Key <> oTargetNode.Key Then If oOldParentNode.Key <> "ROOT" Then End If End If Exit Sub vbErrorHandler: Set mnDragNode = Nothing Set tvwItems.DropHighlight = Nothing ' ' This will more than likely be 'would cause a loop' or whatever ' MsgBox Err.Description, , App.ProductName Effect = vbDropEffectNone End Sub Private Sub tvwItems_OLEDragOver(Data As ComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer) Dim sTmpStr As String Dim nTargetNode As Node On Error Resume Next ' ' First check that we allow this type of data to be dropped here ' sTmpStr = Data.GetFormat(miClipBoardFormat) If Err Or sTmpStr = "False" Then Err.Clear Effect = vbDropEffectNone Exit Sub End If Set nTargetNode = tvwItems.HitTest(X, Y) If nTargetNode Is Nothing Then Set tvwItems.DropHighlight = Nothing Exit Sub End If If nTargetNode.Key = mnDragNode.Key Then Set tvwItems.DropHighlight = Nothing Effect = vbDropEffectNone Else Set tvwItems.DropHighlight = nTargetNode End If If Y > 0 And Y < 300 Then miScrollDir = -1 ElseIf (Y < tvwItems.Height) And Y > (tvwItems.Height - 500) Then miScrollDir = 1 Else miScrollDir = 0 End If End Sub Private Sub tvwItems_OLEStartDrag(Data As ComctlLib.DataObject, AllowedEffects As Long) Dim byt() As Byte ' ' Place the key of the dragged item into the clipboard in our own format ' declared in GetClipboardFormat api ' AllowedEffects = vbDropEffectMove byt = mnDragNode.Key Data.SetData byt, miClipBoardFormat End Sub 
(.txt)